
bugsParallel <- function(data, inits, parameters.to.save,
                         model.file = "model.txt",
                         n.chains = 3, n.iter = 2000,
                         n.burnin = floor(n.iter / 2),
                         n.thin = max(1, floor(n.chains * (n.iter - n.burnin) / 1000)),
                         refresh=100, seed = 314159,
                         bin = (n.iter - n.burnin) / n.thin,
                         debug = FALSE, DIC = TRUE, digits = 5,
                         bugs.directory = "c:/Program Files/WinBUGS14/",
                         clearWD = FALSE,
                         useWINE = .Platform$OS.type != "windows",
                         WINE = Sys.getenv("WINE"),
                         newWINE = FALSE, WINEPATH = NULL) {

    ## bugsParallel launches WinBUGS on multiple processors. Each
    ## distributed job runs one MCMC chain.  Current version is limited to
    ## WinBUGS 1.4.* running on MS Windows or Mac OS X using the Rmpi
    ## package.  It might run on other UNIX environments but it hasn't
    ## been tested.  Many R2WinBUGS components are used or adapted.
    
    ## use scan to read in model file as a character vector so it can be passed to nodes
    model <- scan(model.file, what="", sep="\n", blank.lines.skip = F)

    ## create seeds for each WinBUGS chain
    set.seed(seed)
    seeds <- as.integer(runif(n.chains,0,1.0E6))
    
    runOneChain <- function(i, seeds, data, inits, parameters.to.save, model,
                            n.iter, n.burnin, n.thin, refresh, bin, debug, DIC, digits,
                            bugs.directory, clearWD, useWINE, WINE, newWINE, WINEPATH){

      ## Defining all of the following functions within runOneChain is
      ## an easy way of making all of these helper functions available
      ## on all of the nodes
      
      bugs.chainParallel <- function(data, inits, parameters.to.save,
                                     model, n.iter, n.burnin, n.thin,
                                     seed, refresh, bin, debug, DIC, digits,
                                     bugs.directory, clearWD,
                                     useWINE, WINE, newWINE, WINEPATH){
        write(model,"model.txt")
        model.file <- "model.txt"
        if(!(length(data) == 1 &&
             is.vector(data) &&
             is.character(data) &&
             data == "data.txt")) {
          bugs.data(data, dir = getwd(), digits)
        } else if(!file.exists(data)) {
          stop("File data.txt does not exist.")
        }
        bugs.inits(inits, 1, digits)
        if(DIC) parameters.to.save <- c(parameters.to.save, "deviance")
        
        bugs.scriptParallel(parameters.to.save, n.iter, n.burnin, n.thin,
                            model.file, seed=seed, refresh=refresh,
                            debug=debug, is.inits=!is.null(inits),
                            bin = bin, DIC = DIC,
                            useWINE = useWINE, newWINE = newWINE, 
                            WINEPATH = WINEPATH)
        bugs.runParallel(n.burnin,bugs.directory, newWINE = newWINE,
                         WINE = WINE, useWINE = useWINE, WINEPATH=WINEPATH)
        
        sims <- bugs.simsParallel()
        return(sims)

      }
      
      bugs.data <- function(data, dir = getwd(), digits = 5){
        if(is.numeric(unlist(data)))
          write.datafile(lapply(data, formatC, digits = digits, format = "E"), 
                         file.path(dir, "data.txt"))
        else {
          data.list <- lapply(as.list(data), get, pos = parent.frame(2))
          names(data.list) <- as.list(data)
          write.datafile(lapply(data.list, formatC, digits = digits, format = "E"), 
                         file.path(dir, "data.txt"))
        }
      }
      
      bugs.inits <- function (inits, n.chains, digits){
          if(!is.null(inits)) {
            	for(i in 1:n.chains) {
                	if(is.function(inits))
                		write.datafile(lapply(inits(), formatC, digits = digits, format = "E"),
                    		paste("inits", i, ".txt", sep = ""))
                	else
                          write.datafile(lapply(inits[[i]], formatC, digits = digits, format = "E"), 
                                       paste("inits", i, ".txt", sep = ""))
                      }
              }
              }
      
      write.datafile <-
        function (datalist, towhere, fill = TRUE){
          if (!is.list(datalist) || is.data.frame(datalist)) 
            stop("First argument to write.datafile must be a list.")
          cat(formatdata(datalist), file = towhere, fill = fill)
        }
      
      bugs.scriptParallel <-
        function (parameters.to.save, n.iter, n.burnin,
                  n.thin, model.file, seed=NULL, refresh=100, debug=FALSE,
                  is.inits, bin, DIC = FALSE, 
                  useWINE = FALSE, newWINE = FALSE, WINEPATH = NULL) {
          ## Write file script.txt for Bugs to readhistory

          if((ceiling(n.iter/n.thin) - ceiling(n.burnin/n.thin)) < 2)
            stop ("(n.iter-n.burnin)/n.thin must be at least 2")
          working.directory <- getwd()
          script <- "script.txt"
          model <- if(length(grep("\\\\", model.file)) || length(grep("/", model.file))){
            model.file
          } else file.path(working.directory, model.file)
          data <- file.path(working.directory, "data.txt")
          ## history <- file.path(working.directory, "history.odc")
          coda  <- file.path(working.directory, "coda")
          logfile <- file.path(working.directory, "log.odc")
          ## logfileTxt <- file.path(working.directory, "log.txt")
          inits <- sapply(paste(working.directory, "/inits", 1, ".txt", sep=""), 
                          function(x) native2win(x, WINEPATH = WINEPATH))
          initlist <- paste("inits (", 1, ", '", inits, "')\n", sep="")
          savelist <- paste("set (", parameters.to.save, ")\n", sep="")
          redo <- ceiling((n.iter-n.burnin)/(n.thin*bin))
          
          thinUpdateCommand <- paste("thin.updater (", n.thin, ")\n",
          "update (", ceiling(n.burnin/n.thin), ")\n", sep = "")
          
          cat(
              "display ('log')\n",
              "check ('", native2win(model, WINEPATH = WINEPATH), "')\n",
              if(!is.null(seed)) paste("set.seed(",as.integer(seed),")\n",sep=""),
              "data ('", native2win(data, WINEPATH = WINEPATH), "')\n",
              "compile (", 1, ")\n",
              if(is.inits) initlist,
              "gen.inits()\n",
              "refresh(",refresh,")\n",
              thinUpdateCommand,
              savelist,
              if(DIC) "dic.set()\n",
              rep(
                  c("update (", formatC(ceiling(bin), format = "d"), ")\n",
                    "coda (*, '", native2win(coda, WINEPATH = WINEPATH), "')\n"),redo),
              ## "stats (*)\n",
              if(DIC) "dic.stats()\n",
              ## "history (*, '", native2win(history, WINEPATH = WINEPATH), "')\n",
              "save ('", native2win(logfile, WINEPATH = WINEPATH), "')\n", 
              ## "save ('", native2win(logfileTxt, WINEPATH = WINEPATH), "')\n",
              file=script, sep="", append=FALSE)
          if (!debug) cat ("quit ()\n", file=script, append=TRUE)
          sims.files <- paste ("coda", 1, ".txt", sep="")
          cat ("WinBUGS did not run correctly.\n",
               file=sims.files, append=FALSE)
        }

      
    bugs.runParallel <- function(n.burnin,bugs.directory, WINE = "", 
                                 useWINE = .Platform$OS.type != "windows", 
                                 newWINE = TRUE, WINEPATH = NULL){ 
      
      if(useWINE && !newWINE) bugs.directory <- win2native(bugs.directory)
      
      ## Update the lengths of the adaptive phases in the Bugs updaters
      try(bugs.update.settings(n.burnin, bugs.directory))
      ## Return the lengths of the adaptive phases to their original settings
      on.exit(try(file.copy(file.path(bugs.directory, "System/Rsrc/Registry_Rsave.odc"), 
                            file.path(bugs.directory, "System/Rsrc/Registry.odc"), 
                            overwrite = TRUE)))
      
      ## Search Win*.exe (WinBUGS executable) within bugs.directory
      dos.location <- file.path(bugs.directory, 
                                grep("^Win[[:alnum:]]*[.]exe$",
                                     list.files(bugs.directory), value = TRUE)[1])
      if(!file.exists(dos.location)) 
        stop(paste("WinBUGS executable does not exist in", bugs.directory))
      ## Call Bugs and have it run with script.txt
      ## bugsCall <- paste("\"", dos.location, "\" /par \"",
      ## native2win(file.path(getwd(), "script.txt"), newWINE = newWINE, WINEPATH = WINEPATH),
      ## "\"", sep = "")
      bugsCall <- paste(shQuote(dos.location), " /par ",
                        shQuote(native2win(file.path(getwd(), "script.txt"),
                                           newWINE = newWINE, WINEPATH = WINEPATH)),
                        sep = "")
      if (useWINE)
        bugsCall <- paste(WINE, bugsCall)
    	## The following call appears to break when the command gets
    	## too long. Not sure whether it's the length of the command
    	## string or length of some specific path in the command that
    	## causes the problem. When it breaks, WinBUGS launches but
    	## fails to open a log window, suggesting it couldn't get the
    	## script file. WRGillespie 1/7/2009
      	temp <- system(bugsCall)

      if(temp == -1)
        stop("Error in bugs.run().\nCheck that WinBUGS is in the specified directory.")
      ## Stop and print an error message if Bugs did not run correctly
      if(length(grep("Bugs did not run correctly",
                     scan("coda1.txt", character(), quiet=TRUE, sep="\n"))) > 0)
        stop("Look at the log file and\ntry again with debug=TRUE and figure out what went wrong within Bugs.")
    }
      
      
      bugs.update.settings <- function (n.burnin, bugs.directory){
        
      char.burnin <- as.character(n.burnin - 1)
      if (is.R()){
        file.copy(file.path(bugs.directory, "System/Rsrc/Registry.odc"),
                  file.path(bugs.directory, "System/Rsrc/Registry_Rsave.odc"),
                  overwrite = TRUE)
      } else {
        splus.file.copy(file.path(bugs.directory, "System/Rsrc/Registry.odc"),
                        file.path(bugs.directory, "System/Rsrc/Registry_Rsave.odc"),
                        overwrite = TRUE)
      }
      registry <- readBin(file.path(bugs.directory, "System/Rsrc/Registry.odc"), 
                          "character", 400, size = 1, endian = "little")
      locale <- Sys.getlocale("LC_CTYPE")
      Sys.setlocale("LC_CTYPE", "C")
      if (is.R())  
        info <- registry[regexpr("Int", registry, fixed = TRUE, useBytes = TRUE) > 0]
      else  
        info <- registry[regexpr("Int", registry, fixed = TRUE) > 0]
      while(regexpr("\r", info) > 0){
        newline <- regexpr("\r", info)
        info <- substring(info, newline + 1)
        line <- substring(info, 1, regexpr("\r", info) - 1)
        if(regexpr("AdaptivePhase", line) > 0){
          if (is.R())
            numpos <- regexpr("Int", line, fixed = TRUE, useBytes = TRUE) + 4
          else
            numpos <- regexpr("Int", line, fixed = TRUE) + 4
          
          num <- substring(line, numpos)
          if (as.numeric(num) > n.burnin){
            blanks <- rep(" ", nchar(num, type = "chars") - nchar(char.burnin, type = "chars"))
            num.new <- paste(paste(blanks, collapse = ""), char.burnin, sep = "")
            line.new <- sub(num, num.new, line)
            registry <- sub(line, line.new, registry)
          }
        }
      }
      Sys.setlocale("LC_CTYPE", locale)
      writeBin (registry,
                file.path(bugs.directory, "System/Rsrc/Registry.odc"), endian = "little")
    }
      
      splus.file.copy <-
        function(from, to, overwrite = FALSE)
          {
            if(!file.exists(from))
              stop("File: ", from, " does not exist")
            if(!overwrite && file.exists(to))
              stop("File: ", to, " already exists and overwrite is FALSE")
            n <- file.info(from)$size
            z <- writeBin(readBin(from, what = "integer", size = 1, n = n), to,
                          size = 1)
            invisible(z)
          }
      
    "bugs.simsParallel" <-
    function (){
      ## Read the simulations from Bugs into R, format them, and monitor convergence

      sims.files <- paste ("coda", 1, ".txt", sep="")
      index <- read.table("codaIndex.txt", header = FALSE, sep = "\t")    # read in the names of the parameters and the indices of their samples
      parameter.names <- as.vector(index[, 1])
      n.keep <- index[1, 3] - index[1, 2] + 1
      n.parameters <- length(parameter.names)
      n.sims <- n.keep
      ## sims <- matrix( , n.sims, n.parameters)

      sims <- scan(sims.files, what=list(NULL,""), quiet = TRUE)[[2]][(1:(n.keep * n.parameters))]
      sims <- matrix(as.numeric(ifelse(sims=="inf","Inf",ifelse(sims=="-inf","-Inf",sims))), n.sims, n.parameters)
      ## sims <- matrix(scan(sims.files, quiet = TRUE)[2 * (1:(n.keep * n.parameters))], n.sims, n.parameters)
      dimnames (sims) <- list (NULL, parameter.names)
      return(sims)
    }

      ## from Jun Yan's rbugs package, extended
      
      if (is.R()){
        
        ## get drive mapping table from ~/.wine/config
        winedriveMap <- function(config="~/.wine/config") {
          if (!file.exists(config)) return (NULL);
          con <- readLines(config)
          con <- con[- grep("^;", con)]
          drive <- con[grep("^\\[Drive ", con)]
          drive <- substr(drive, 8, 8)
          drive <- paste(drive, ":", sep="")
          path <- con[grep("Path", con)]
          len <- length(drive)
          path <- path[1:len]
          dir <- sapply(path, 
                        function(x) {
                          foo <- unlist(strsplit(x, "\""))
                          foo[length(foo)]
                        })
          dir <- sub("%HOME%",tools::file_path_as_absolute("~"),dir)
          data.frame(drive = I(drive), path = I(dir), row.names=NULL)
        }
        ## translate windows dir to native dir
        winedriveTr <- function(windir, DriveTable=winedriveMap()) {
          win.dr <- substr(windir, 1, 2)
          ind <- pmatch(toupper(win.dr), DriveTable$drive)
          native.dr <- DriveTable$path[ind]
          sub(win.dr, native.dr, windir)
        }
        
        ## translate full Unix path to Wine path
        winedriveRTr <- function(unixpath, DriveTable=winedriveMap()) {
          blocks <- strsplit(unixpath,"/")[[1]]
          cblocks <- c("/",sapply(1+seq(along=blocks[-1]),
                                  function(n) paste(blocks[1:n],collapse="/")))
          path <- match(cblocks,DriveTable$path)
          if (any(!is.na(path))) {
            unixdir <- cblocks[which.min(path)]
            windrive <- paste(DriveTable$drive[min(path,na.rm=TRUE)],"/",sep="")
            winpath <- sub("//","/",sub(unixdir,windrive,unixpath)) ## kluge
          } else stop("can't find equivalent Windows path: file may be inaccessible")
          winpath
        }
        
        
        win2native <- function(x, useWINE=.Platform$OS.type != "windows") { # win -> native
          if (useWINE) winedriveTr(x)
          else x
        }
        
      } # end if (is.R())
      
      native2win <- function(x, useWINE=.Platform$OS.type != "windows", newWINE=TRUE, WINEPATH=NULL) { # native -> win
        if(is.R()){
          if (useWINE && !newWINE) return(winedriveRTr(x))
          if (useWINE && newWINE) {
            x <- system(paste(WINEPATH, "-w", x), intern = TRUE)
            return(gsub("\\\\", "/", x)) ## under wine BUGS cannot use \ or \\
          } else x
        } else { #S-PLUS
          gsub("\\\\", "/", x)  
        }
      }
      
      "formatdata" <-
        function (datalist){
          if (!is.list(datalist) || is.data.frame(datalist)) 
            stop("Argument to formatdata() must be a list.")
          n <- length(datalist)
          datalist.string <- vector(n, mode = "list")
          for (i in 1:n) {
            if (length(datalist[[i]]) == 1) 
              datalist.string[[i]] <- paste(names(datalist)[i], 
                                            "=", as.character(datalist[[i]]), sep = "")
            if (is.vector(datalist[[i]]) && length(datalist[[i]]) > 1) 
              datalist.string[[i]] <- paste(names(datalist)[i], 
                                            "=c(", paste(as.character(datalist[[i]]), collapse = ", "), 
                                            ")", sep = "")
            if (is.array(datalist[[i]])) 
              datalist.string[[i]] <- paste(names(datalist)[i], 
                                            "= structure(.Data= c(", paste(as.character(as.vector(aperm(datalist[[i]]))), 
                                                           collapse = ", "), "), .Dim=c(", paste(as.character(dim(datalist[[i]])), 
                                                                                   collapse = ", "), "))", sep = "")
          }
          datalist.tofile <- paste("list(", paste(unlist(datalist.string), 
                                                  collapse = ", "), ")", sep = "")
          return(datalist.tofile)
        }
      
      copy.dir <- function(source,
                           target,
                           unlink.target=FALSE,
                           overwrite=FALSE,
                           verbose=FALSE) {

        ## WRGillespie 1/2/2009: Adapted from copy.dir function in
	## roxygen package Recursively copy a directory thither;
	## optionally unlinking the target first; optionally
	## overwriting; optionally verbalizing.

        ##' @param source the source directory
	##' @param target the target directory
	##' @param unlink.target delete target directory first?
	##' @param overwrite overwrite target files?
	##' @param verbose verbalize transaction?
	##' @return \code{NULL}
	##' @note Not tested on non-linux platforms
        
        if (unlink.target)
          unlink(target, recursive=TRUE)
        files <- list.files(source, full.name=FALSE, recursive=TRUE)
        for (source.file in files) {
          target.file <- file.path(target, source.file)
          target.dir <- dirname(target.file)
          ## Could create, instead, a list of unique directories in
          ## Theta(n).
          dir.create(target.dir, recursive=TRUE, showWarnings=FALSE)
          if (verbose)
            cat(sprintf('%s -> %s', source.file, target.file), '\n')
          file.copy(file.path(source, source.file), target.file, overwrite=overwrite)
        }
      }
      
      wd.orig <- getwd()
      wd <- paste(wd.orig,"/",i,sep="")
      dir.create(wd) 
      
      setwd(wd)
      on.exit(setwd(wd.orig)) # return to wd.orig even if error occurs
      new.bugs.directory <- paste(getwd(),"/winbugs14/",sep="")
      copy.dir(bugs.directory, new.bugs.directory)

      sims <- bugs.chainParallel(data, inits, parameters.to.save, model,
        n.iter, n.burnin, n.thin, seeds[i], refresh, bin, debug, DIC, digits,
        bugs.directory=new.bugs.directory, clearWD,
        useWINE, WINE, newWINE, WINEPATH)

      setwd(wd.orig)

      if(clearWD)
        unlink(wd, recursive=T)
      else
        unlink(substring(new.bugs.directory,1,nchar(new.bugs.directory)-1), recursive=T)
      sims
      
    }
    
    ## Back to the main level of bugsParallel ... 
    
    if (useWINE) {
      if (!nchar(WINE)) {
        WINE <- system("locate wine | grep bin/wine$", intern = TRUE)
        WINE <- WINE[length(WINE)]
      }
      if (!length(WINE)) 
        stop("couldn't locate WINE binary")
      if (!nchar(WINEPATH)) {
        WINEPATH <- system("locate winepath | grep bin/winepath$", 
                           intern = TRUE)
        WINEPATH <- WINEPATH[length(WINEPATH)]
      }
      if (!length(WINEPATH)) 
        stop("couldn't locate WINEPATH binary")
    }
    
    ## distribute chains to nodes 
    listOfChains <- mpi.applyLB(1:n.chains, runOneChain,
                              seeds = seeds, data = data, inits = inits,
                              parameters.to.save = parameters.to.save, model = model,
                              n.iter = n.iter, n.burnin = n.burnin, n.thin = n.thin,
                              refresh = refresh, bin = bin, debug = debug, DIC = DIC,
                              digits = digits, bugs.directory = bugs.directory, clearWD = clearWD,
                              useWINE=useWINE, WINE=WINE, newWINE=newWINE, WINEPATH=WINEPATH)

    return(listOfChains)
    
  }


